home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / compiler / Asyntfn.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  13.2 KB  |  450 lines  |  [TEXT/R*ch]
  1. open List Fnlib Mixture Const Globals Location Types Asynt;
  2.  
  3. fun mkIdInfo (loc, qualid) withOp =
  4.   { qualid = qualid,
  5.     info = { idLoc=loc, withOp=withOp,
  6.              idKind= ref { qualid=qualid, info=VARik }}}
  7. ;
  8.  
  9. fun getConInfo (ii : IdInfo) =
  10.   case #info(! (#idKind (#info ii))) of
  11.       CONik ci => ci
  12.     | _ => fatalError "getConInfo"
  13. ;
  14.  
  15. fun getExConInfo (ii : IdInfo) =
  16.   case #info(!(#idKind (#info ii))) of
  17.       EXCONik ei => ei
  18.     | _ => fatalError "getExConInfo"
  19. ;
  20.  
  21. fun pairExp e1 e2 =
  22.   (xxLR e1 e2, RECexp(ref (RECre(mkPairRow e1 e2))))
  23. ;
  24.  
  25. fun tupleExp (loc, exps) =
  26.   (loc, RECexp(ref (RECre(mkTupleRow exps))))
  27. ;
  28.  
  29. val qQUOTE  = { qual = "General", id = "QUOTE" };
  30. val qANTIQUOTE = { qual = "General", id = "ANTIQUOTE" };
  31.  
  32. fun quoteExp exp =
  33.   let val loc = xLR exp in
  34.     (loc, APPexp((loc,
  35.        VARexp(ref (RESve(mkIdInfo (loc, qQUOTE) false)))), exp))
  36.   end
  37. ;
  38.  
  39. fun antiquoteExp exp =
  40.   let val loc = xLR exp in
  41.     (loc, APPexp((loc,
  42.        VARexp(ref (RESve(mkIdInfo (loc, qANTIQUOTE) false)))), exp))
  43.   end
  44. ;
  45.  
  46. val qNil  = { qual = "", id = "nil" };
  47. val qCons = { qual = "", id = "::" };
  48.  
  49. fun listExp (Loc(l,r), exps) =
  50.   let val locR = Loc(r-1,r) in
  51.     foldR (fn e1 => fn e2 =>
  52.              let val locO = xxLR e1 e2
  53.                  val locI = xxRL e1 e2
  54.              in
  55.                (locO, APPexp((locI,
  56.                         VARexp(ref (RESve(mkIdInfo (locI, qCons) false)))),
  57.                           pairExp e1 e2))
  58.              end)
  59.           (locR, VARexp(ref (RESve(mkIdInfo (locR,qNil) false)))) exps
  60.   end;
  61.  
  62. fun seqExp exps =
  63.   foldR1 (fn e1 => fn e2 =>
  64.             let val loc12 = xxLR e1 e2 in (loc12, SEQexp(e1,e2)) end)
  65.          exps
  66. ;
  67.  
  68. val qX = { qual = "", id = "~x" };
  69.  
  70. fun hashLabelExp (loc, lab) =
  71.   let val pat =
  72.         (loc, RECpat(ref
  73.                 (RECrp([(lab, (loc, VARpat(mkIdInfo (loc,qX) false)))],
  74.                        SOME (fresh3DotType())))))
  75.       and exp =
  76.         (loc, VARexp(ref (RESve(mkIdInfo (loc, qX) false))))
  77.   in (loc, FNexp [MRule([pat],exp)]) end
  78. ;
  79.  
  80. fun mkLabPatOfId (locId as (loc, id)) ty_opt pat_opt =
  81.   let val lab = STRINGlab id
  82.       val var = (loc, VARpat(mkIdInfo (loc, { qual="", id=id }) false))
  83.   in
  84.     case (ty_opt, pat_opt) of
  85.         (SOME ty, SOME pat) =>
  86.           (lab, (xxLR locId pat, LAYEREDpat(var,
  87.                    (xxLR ty pat, TYPEDpat(pat, ty)))))
  88.       | (NONE, SOME pat) =>
  89.           (lab, (xxLR locId pat, LAYEREDpat(var, pat)))
  90.       | (SOME ty, NONE) =>
  91.           (lab, (xxLR locId ty, TYPEDpat(var, ty)))
  92.       | (NONE, NONE) =>
  93.           (lab, var)
  94.   end;
  95.  
  96. fun pairPat p1 p2 =
  97.   let val loc = xxLR p1 p2 in
  98.     (loc, RECpat(ref (RECrp(mkPairRow p1 p2, NONE))))
  99.   end;
  100.  
  101. fun tuplePat (loc, pats) =
  102.   (loc, RECpat(ref (RECrp(mkTupleRow pats, NONE))))
  103. ;
  104.  
  105. fun listPat (Loc(l,r), exps) =
  106.   let val locR = Loc(r-1,r) in
  107.     foldR (fn e1 => fn e2 =>
  108.              let val locO = xxLR e1 e2
  109.                  val locI = xxRL e1 e2
  110.              in
  111.                (locO, CONSpat(mkIdInfo (locI,qCons) true, pairPat e1 e2))
  112.              end)
  113.           (locR, (VARpat (mkIdInfo (locR, qNil) true))) exps
  114.   end;
  115.  
  116. fun tupleTy [t] = t
  117.   | tupleTy ts =
  118.       let val loc = xxLR (hd ts) (last ts) in
  119.         (loc, RECty (mkTupleRow ts))
  120.       end
  121. ;
  122.  
  123. val qIt = { qual = "", id = "it" };
  124.  
  125. fun mkValIt exp =
  126.   let val loc = xLR exp in
  127.     (loc, VALdec
  128.       ([ValBind((loc, VARpat (mkIdInfo (loc, qIt) false)), exp)], []))
  129.   end;
  130.  
  131. fun domPatAcc (_, pat') ids =
  132.   case pat' of
  133.     SCONpat _ => ids
  134.   | VARpat ii => #id(#qualid ii) :: ids
  135.   | WILDCARDpat => ids
  136.   | NILpat _ => ids
  137.   | CONSpat(_, p) => domPatAcc p ids
  138.   | EXNILpat _ => ids
  139.   | EXCONSpat(_, p) => domPatAcc p ids
  140.   | EXNAMEpat _ => fatalError "domPatAcc"
  141.   | REFpat p => domPatAcc p ids
  142.   | RECpat(ref (RECrp(fs, _))) =>
  143.       foldL_map domPatAcc snd ids fs
  144.   | RECpat(ref (TUPLErp ps)) =>
  145.       foldL domPatAcc ids ps
  146.   | VECpat ps =>
  147.       foldL domPatAcc ids ps
  148.   | INFIXpat _ => fatalError "domPatAcc"
  149.   | PARpat p => domPatAcc p ids
  150.   | TYPEDpat(p,_) => domPatAcc p ids
  151.   | LAYEREDpat(p1,p2) => domPatAcc p2 (domPatAcc p1 ids)
  152. ;
  153.  
  154. fun domPat pat = domPatAcc pat [];
  155.  
  156. fun varsOfPatAcc (_, pat') iis =
  157.   case pat' of
  158.     SCONpat _ => iis
  159.   | VARpat ii => ii :: iis
  160.   | WILDCARDpat => iis
  161.   | NILpat _ => iis
  162.   | CONSpat(_, p) => varsOfPatAcc p iis
  163.   | EXNILpat _ => iis
  164.   | EXCONSpat(_, p) => varsOfPatAcc p iis
  165.   | EXNAMEpat _ => fatalError "varsOfPatAcc"
  166.   | REFpat p => varsOfPatAcc p iis
  167.   | RECpat(ref (RECrp(fs, _))) => foldL_map varsOfPatAcc snd iis fs
  168.   | RECpat(ref (TUPLErp _)) => fatalError "varsOfPatAcc"
  169.   | VECpat ps => foldL varsOfPatAcc iis ps
  170.   | INFIXpat _ => fatalError "varsOfPatAcc"
  171.   | PARpat p => varsOfPatAcc p iis
  172.   | TYPEDpat(p,_) => varsOfPatAcc p iis
  173.   | LAYEREDpat(p1,p2) => varsOfPatAcc p2 (varsOfPatAcc p1 iis)
  174. ;
  175.  
  176. fun varsOfTyAcc (_, ty') iis =
  177.   case ty' of
  178.     TYVARty ii => ii :: iis
  179.   | RECty fs =>
  180.       foldR_map varsOfTyAcc snd iis fs
  181.   | CONty(tys, _) =>
  182.       foldR varsOfTyAcc iis tys
  183.   | FNty(ty, ty') =>
  184.       varsOfTyAcc ty (varsOfTyAcc ty' iis)
  185. ;
  186.  
  187. fun varsOfTy ty = varsOfTyAcc ty [];
  188.  
  189. fun curriedness (MRule(pats,_) :: _) = List.length pats
  190.   | curriedness _ = fatalError "curriedness"
  191. ;
  192.  
  193. fun printIdInfo (ii : IdInfo) =
  194.   let val {qualid, info} = ii in
  195.     if #withOp info then msgString "op " else ();
  196.     printQualId qualid
  197.   end;
  198.  
  199. fun printTyVarSeq [] = ()
  200.   | printTyVarSeq [ii] =
  201.       (printIdInfo ii; msgString " ")
  202.   | printTyVarSeq iis =
  203.       (msgString "("; printSeq printIdInfo ", " iis;
  204.        msgString ") ")
  205. ;
  206.  
  207. fun printTy (_, ty') =
  208.   case ty' of
  209.     TYVARty ii =>
  210.       msgString (#id (#qualid ii))
  211.   | RECty fs =>
  212.       (msgString "{"; printSeq printRecTyField ", " fs; msgString ")")
  213.   | CONty(ts, tc) =>
  214.       (printTySeq ts; printQualId (#qualid tc))
  215.   | FNty(t, t') =>
  216.       (msgString "("; printTy t; msgString " -> "; printTy t';
  217.        msgString ")")
  218.  
  219. and printRecTyField (lab, ty) =
  220.   (msgIBlock 0; printLab lab; msgString " ="; msgBreak(1, 2); printTy ty;
  221.    msgEBlock())
  222.  
  223. and printTySeq [] = ()
  224.   | printTySeq [t] =
  225.       (printTy t; msgString " ")
  226.   | printTySeq ts =
  227.       (msgString "("; printSeq printTy ", " ts;
  228.        msgString ")")
  229. ;
  230.  
  231. fun printOvlType ovltype tau =
  232. (
  233.   msgString
  234.     (case ovltype of
  235.          REGULARo => "</ "
  236.        | OVL1NNo => "<num -> num/ "
  237.        | OVL1NSo => "<num -> string/ "
  238.        | OVL2NNBo => "<num * num -> bool/ "
  239.        | OVL2NNNo => "<num * num -> num/ "
  240.        | OVL1TXX => "<'a -> 'a/ ");
  241.   printType tau;
  242.   msgString " > "
  243. );
  244.  
  245. fun printExp (_, exp') =
  246.   case exp' of
  247.     SCONexp scon =>
  248.       printSCon scon
  249.   | VARexp(ref(RESve ii)) =>
  250.       printIdInfo ii
  251.   | VARexp(ref(OVLve(ii, ovltype, tau))) =>
  252.       (printIdInfo ii;
  253.        printOvlType ovltype tau)
  254.   | RECexp(ref (RECre fs)) =>
  255.       (msgString "{"; printSeq printExpField ", " fs;
  256.        msgString "}")
  257.   | RECexp(ref (TUPLEre es)) =>
  258.       (msgString "("; printSeq printExp ", " es;
  259.        msgString ")")
  260.   | VECexp es =>
  261.       (msgString "#["; printSeq printExp ", " es;
  262.        msgString "]")
  263.   | PARexp e => printExp e
  264.   | FNexp mrules =>
  265.       (msgString "(fn "; printSeq printMRule " | " mrules;
  266.        msgString ")")
  267.   | APPexp (e1,e2) =>
  268.       (msgString "("; printSeq printExp " " [e1,e2];
  269.        msgString ")")
  270.   | LETexp (dec,exp) =>
  271.       (msgString "let "; printDec dec; msgString " in ";
  272.        printExp exp; msgString " end")
  273.   | INFIXexp es =>
  274.       (msgString "(INFIXexp ";
  275.        printSeq printExp " " es;
  276.        msgString ")")
  277.   | TYPEDexp(exp,ty) =>
  278.       (msgString "("; printExp exp; msgString " : ";
  279.        printTy ty; msgString ")")
  280.   | ANDALSOexp(exp1,exp2) =>
  281.       (printExp exp1; msgString " andalso "; printExp exp2)
  282.   | ORELSEexp(exp1,exp2) =>
  283.       (printExp exp1; msgString " orelse "; printExp exp2)
  284.   | HANDLEexp(exp, mrules) =>
  285.       (msgString "("; printExp exp; msgString " handle ";
  286.        printSeq printMRule " | " mrules; msgString ")")
  287.   | RAISEexp exp =>
  288.       (msgString "raise "; printExp exp)
  289.   | IFexp(exp0,exp1,exp2) =>
  290.       (msgString "if "; printExp exp0; msgString " then ";
  291.        printExp exp1; msgString " else "; printExp exp2)
  292.   | WHILEexp(exp1,exp2) =>
  293.       (msgString "while "; printExp exp1; msgString " do ";
  294.        printExp exp2)
  295.   | SEQexp(exp1,exp2) =>
  296.       (msgString "("; printExp exp1; msgString "; ";
  297.        printExp exp2; msgString ")")
  298.  
  299. and printExpField (lab, e) =
  300.   (msgIBlock 0; printLab lab; msgString " ="; msgBreak(1, 2);
  301.    printExp e; msgEBlock())
  302.  
  303. and printMRule (MRule(ps, e)) =
  304.       (printSeq printPat " => " ps; msgString " => "; printExp e)
  305.  
  306. and printPat (_, pat') =
  307.   case pat' of
  308.     SCONpat scon => printSCon scon
  309.   | VARpat ii => printIdInfo ii
  310.   | WILDCARDpat => msgString "_"
  311.   | NILpat ii => printIdInfo ii
  312.   | CONSpat(ii, p) =>
  313.       (msgString "("; printIdInfo ii; printPat p; msgString ")")
  314.   | EXNILpat ii => printIdInfo ii
  315.   | EXCONSpat(ii,p) =>
  316.       (msgString "("; printIdInfo ii; printPat p; msgString ")")
  317.   | EXNAMEpat ii =>
  318.       (msgString "<"; printIdInfo ii; msgString ">")
  319.   | REFpat p =>
  320.       (msgString "("; msgString "ref "; printPat p; msgString ")")
  321.   | RECpat(ref (RECrp(fs, dots))) =>
  322.       (msgString "{"; printSeq printPatField ", " fs;
  323.        case dots of
  324.            NONE =>
  325.              msgString "}"
  326.          | SOME _ =>
  327.              msgString ", ...}")
  328.   | RECpat(ref (TUPLErp ps)) =>
  329.       (msgString "("; printSeq printPat ", " ps; msgString ")")
  330.   | VECpat ps =>
  331.       (msgString "#["; printSeq printPat ", " ps; msgString "]")
  332.   | PARpat p =>
  333.       printPat p
  334.   | INFIXpat ps =>
  335.       (msgString "(INFIXpat";
  336.        app (fn p => (msgString " "; printPat p)) ps;
  337.        msgString ")")
  338.   | TYPEDpat(pat, ty) =>
  339.       (msgString "("; printPat pat; msgString " : ";
  340.        printTy ty; msgString ")")
  341.   | LAYEREDpat(pat1, pat2) =>
  342.       (msgString "("; printPat pat1; msgString " as ";
  343.        printPat pat2; msgString ")")
  344.  
  345. and printPatField (lab, pat) =
  346.   (msgIBlock 0; printLab lab; msgString " ="; msgBreak(1, 2);
  347.    printPat pat; msgEBlock())
  348.  
  349. and printDec (_, dec') =
  350.   case dec' of
  351.     VALdec (pvbs, rvbs) =>
  352.       (msgString "val ";
  353.        case (pvbs, rvbs) of
  354.           (_, []) => printValBindSeq pvbs
  355.         | ([], _) => (msgString "rec "; printValBindSeq rvbs)
  356.         | (_, _) => (printValBindSeq pvbs; msgString " and rec ";
  357.                      printValBindSeq rvbs))
  358.   | PRIM_VALdec vbs =>
  359.       (msgString "prim_val "; printSeq printPrimValBind " and " vbs)
  360.   | FUNdec fvalbind =>
  361.       (msgString "fun "; printSeq printFValBind " and " fvalbind)
  362.   | TYPEdec tbs =>
  363.       (msgString "type "; printSeq printTypBind " and " tbs)
  364.   | PRIM_TYPEdec(eq, tbs) =>
  365.       (msgString "prim_";
  366.        msgString
  367.          (case eq of
  368.               FALSEequ => ""
  369.             | TRUEequ  => "eq"
  370.             | REFequ   => "EQ");
  371.        msgString "type "; printSeq printPrimTypBind " and " tbs)
  372.   | DATATYPEdec(dbs, tbs_opt) =>
  373.       (msgString "datatype "; printSeq printDatBind " and " dbs;
  374.        printWithtype tbs_opt)
  375.   | ABSTYPEdec(dbs, tbs_opt, dec) =>
  376.       (msgString "abstype "; printSeq printDatBind " and " dbs;
  377.        printWithtype tbs_opt;
  378.        msgString " with "; printDec dec)
  379.   | EXCEPTIONdec ebs =>
  380.       (msgString "exception "; printSeq printExBind " and " ebs)
  381.   | LOCALdec(dec1,dec2) =>
  382.       (msgString "local "; printDec dec1; msgString " in ";
  383.        printDec dec2)
  384.   | OPENdec ids =>
  385.       (msgString "OPEN "; printSeq msgString " " ids)
  386.   | EMPTYdec => ()
  387.   | SEQdec(dec1,dec2) =>
  388.       (printDec dec1; msgString "; "; printDec dec2)
  389.   | FIXITYdec(status, ids) =>
  390.       (case status of
  391.            INFIXst i =>
  392.              (msgString "INFIX "; msgInt i; msgString " ")
  393.          | INFIXRst i =>
  394.              (msgString "INFIXR "; msgInt i; msgString " ")
  395.          | NONFIXst =>
  396.              msgString "NONFIX ";
  397.        printSeq msgString " " ids)
  398.  
  399. and printValBindSeq vbs =
  400.   printSeq printValBind " and " vbs
  401.  
  402. and printValBind (ValBind(p, e)) =
  403.   (msgIBlock 0; printPat p; msgString " ="; msgBreak(1, 2);
  404.    printExp e; msgEBlock())
  405.  
  406. and printPrimValBind(ii, ty, arity, name) =
  407.   (msgIBlock 0; printIdInfo ii;
  408.    msgString " :"; msgBreak(1, 2);
  409.    printTy ty; msgString " ="; msgBreak(1, 2);
  410.    msgInt arity; msgString " "; printSCon (STRINGscon name);
  411.    msgEBlock())
  412.  
  413. and printFValBind (_, fclauses) =
  414.   (printSeq printFClause " | " fclauses)
  415.  
  416. and printFClause (FClause (pats, exp)) =
  417.   (msgIBlock 0; printSeq printPat " " pats; msgString " ="; msgBreak(1, 2);
  418.    printExp exp; msgEBlock())
  419.  
  420. and printWithtype (SOME tbs) =
  421.       (msgString " withtype "; printSeq printTypBind " and " tbs)
  422.   | printWithtype NONE = ()
  423.  
  424. and printTypBind (tvs, tc, t) =
  425.   (msgIBlock 0; printTyVarSeq tvs; msgString (#id (#qualid tc));
  426.    msgString " ="; msgBreak(1, 2);
  427.    printTy t; msgEBlock())
  428.  
  429. and printPrimTypBind (tvs, tc) =
  430.   (printTyVarSeq tvs; msgString (#id (#qualid tc)))
  431.  
  432. and printDatBind (tvs, tc, cbs) =
  433.   (msgIBlock 0; printTyVarSeq tvs; msgString (#id (#qualid tc));
  434.    msgString " ="; msgBreak(1, 2);
  435.    printSeq printConBind " | " cbs; msgEBlock())
  436.  
  437. and printConBind (ConBind(ii, SOME t)) =
  438.       (printIdInfo ii; msgString " of "; printTy t)
  439.   | printConBind (ConBind(ii, NONE)) =
  440.       printIdInfo ii
  441.  
  442. and printExBind (EXDECexbind(ii, SOME t)) =
  443.       (printIdInfo ii; msgString " of "; printTy t)
  444.   | printExBind (EXDECexbind(ii, NONE)) =
  445.       printIdInfo ii
  446.   | printExBind (EXEQUALexbind(ii, ii')) =
  447.       (msgIBlock 0; printIdInfo ii; msgString " ="; msgBreak(1, 2);
  448.        printIdInfo ii'; msgEBlock())
  449. ;
  450.